home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
ADA Programming Guide
/
ADA Programming Guide.iso
/
ada_tut
/
vax.ada
< prev
Wrap
Text File
|
1996-01-30
|
5KB
|
114 lines
-- VAX.ADA Ver. 3.00 22-AUG-1994 Copyright 1988-1994 John J. Herro
-- Software Innovations Technology
-- 1083 Mandarin Drive NE, Palm Bay, FL 32905-4706 (407)951-0233
--
-- Compile this before compiling ADA_TUTR.ADA with VAX Ada. See first page of
-- ADA_TUTR.ADA for more details.
--
package Custom_IO is
type Color is (Black, Red, Green, Yellow, Blue, Magenta, Cyan, White);
Foregrnd_Color : Color := White; -- Default values in case
Backgrnd_Color : Color := Black; -- ADA-TUTR finds no User
Border_Color : Color := Black; -- File.
Fore_Color_Digit : Character := Character'Val(Color'Pos(Foregrnd_Color)+48);
Back_Color_Digit : Character := Character'Val(Color'Pos(Backgrnd_Color)+48);
Normal_Colors : String(1 .. 10) := ASCII.ESC & "[0;3" &
Fore_Color_Digit & ";4" & Back_Color_Digit & "m";
Clear_Scrn : constant String := ASCII.ESC & "[H" & ASCII.ESC & "[2J";
procedure Set_Border_Color (To : in Color);
procedure Get (Char : out Character);
procedure Put (Char : in Character);
procedure Put (Str : in String);
procedure Put_Line (Str : in String);
procedure Get_Line (Str : out String; Last : out Natural);
procedure New_Line;
end Custom_IO;
with Starlet, System; use Starlet, System;
package body Custom_IO is
Chan : Starlet.Channel_Type;
IOSB : System.Unsigned_Quadword;
Stat : System.Unsigned_Longword;
procedure QIOW(Stat : out Unsigned_Longword; EFN : in Integer;
Chan : in Channel_Type; Func : in Short_Integer;
IOSB : out Unsigned_Quadword; ASTadr : in Integer; ASTPRM : in Integer;
P1 : in out String; P2, P3 : in Integer; P4 : in Unsigned_Quadword;
P5, P6 : in Integer); -- Pragma Interface is used for
pragma Interface(System_Library, QIOW); -- compatibility with Ada 83.
pragma Import_Valued_Procedure(Internal => QIOW, External => "SYS$QIOW",
Parameter_Types => (Unsigned_Longword, Integer, Channel_Type,
Short_Integer, Unsigned_Quadword, Integer, Integer, String,
Integer, Integer, Unsigned_Quadword, Integer, Integer),
Mechanism => (Value, Value, Value, Value, Reference, Value, Reference,
Reference, Value, Reference, Reference, Reference, Reference));
procedure Set_Border_Color(To : in Color) is
-- Dummy procedure for computers other than PCs.
begin
null;
end Set_Border_Color;
procedure Get(Char : out Character) is
S : String(1 .. 1);
begin
QIOW(Stat, 0, Chan, 16#7A#, IOSB, 0, 0, S, 1, 0, (0,0), 0, 0);
Char := S(1);
end Get;
procedure Put(Char : in Character) is
begin
Put(Char & "");
end PUT;
procedure Put(Str : in String) is
S : String(Str'Range) := Str;
begin
QIOW(Stat, 0, Chan, 16#70#, IOSB, 0, 0, S, S'Length, 0, (0,0), 0, 0);
end PUT;
procedure Put_Line(Str : in String) is
begin
Put(Str & ASCII.CR & ASCII.LF);
end Put_Line;
procedure Get_Line(Str : out String; Last : out Natural) is separate;
procedure New_Line is
begin
Put(ASCII.CR & ASCII.LF);
end New_Line;
begin
Starlet.Assign(Stat, "TT:", Chan);
end Custom_IO;
-- This procedure gets a string from the terminal, while allowing typing errors
-- to be corrected.
--
separate (Custom_IO)
procedure Get_Line(Str : out String; Last : out Natural) is
S : String(Str'Range); -- Local copy of Str.
Char : Character := ' '; -- One character from keyboard.
Place : Integer := Str'First; -- Position of next available character.
begin
while Char /= ASCII.CR loop -- CR signifies end of string.
Get(Char); -- Get one character.
if Char = ASCII.CR then
New_Line; -- Give new line at end of the string.
elsif Char = ASCII.BS or Char = ASCII.DEL then
if Place > Str'First then -- Ignore BS/DEL when string is null.
Put(ASCII.BS & ' ' & ASCII.BS); -- Erase last char. from display.
Place := Place - 1; -- Remove last char. from string.
end if;
elsif Place > Str'Last then -- Beep when length of string is exceeded.
Put(ASCII.BEL);
else
Put(Char); -- Echo the character typed.
S(Place) := Char; -- Add character to the string.
Place := Place + 1;
end if;
end loop;
Str(Str'First .. Place - 1) := S(Str'First .. Place - 1);
Last := Place - 1;
end Get_Line;